home *** CD-ROM | disk | FTP | other *** search
/ Freelog 125 / Freelog_MarsAvril2015_No125.iso / ViePratique / gnucash / gnucash-2.6.5-setup.exe / {app} / bin / intltool-extract~ < prev    next >
Text File  |  2008-09-23  |  24KB  |  902 lines
  1. #!/opt/perl/bin/perl -w 
  2. # -*- Mode: perl; indent-tabs-mode: nil; c-basic-offset: 4  -*-
  3.  
  4. #
  5. #  The Intltool Message Extractor
  6. #
  7. #  Copyright (C) 2000-2001, 2003 Free Software Foundation.
  8. #
  9. #  Intltool is free software; you can redistribute it and/or
  10. #  modify it under the terms of the GNU General Public License as
  11. #  published by the Free Software Foundation; either version 2 of the
  12. #  License, or (at your option) any later version.
  13. #
  14. #  Intltool is distributed in the hope that it will be useful,
  15. #  but WITHOUT ANY WARRANTY; without even the implied warranty of
  16. #  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  17. #  General Public License for more details.
  18. #
  19. #  You should have received a copy of the GNU General Public License
  20. #  along with this program; if not, write to the Free Software
  21. #  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  22. #
  23. #  As a special exception to the GNU General Public License, if you
  24. #  distribute this file as part of a program that contains a
  25. #  configuration script generated by Autoconf, you may include it under
  26. #  the same distribution terms that you use for the rest of that program.
  27. #
  28. #  Authors: Kenneth Christiansen <kenneth@gnu.org>
  29. #           Darin Adler <darin@bentspoon.com>
  30. #
  31.  
  32. ## Release information
  33. my $PROGRAM      = "intltool-extract";
  34. my $PACKAGE      = "intltool";
  35. my $VERSION      = "0.40.4";
  36.  
  37. ## Loaded modules
  38. use strict; 
  39. use File::Basename;
  40. use Getopt::Long;
  41.  
  42. ## Scalars used by the option stuff
  43. my $TYPE_ARG    = "0";
  44. my $LOCAL_ARG    = "0";
  45. my $HELP_ARG     = "0";
  46. my $VERSION_ARG = "0";
  47. my $UPDATE_ARG  = "0";
  48. my $QUIET_ARG   = "0";
  49. my $SRCDIR_ARG    = ".";
  50. my $NOMSGCTXT_ARG = "0";
  51.  
  52. my $FILE;
  53. my $OUTFILE;
  54.  
  55. my $gettext_type = "";
  56. my $input;
  57. my %messages = ();
  58. my %loc = ();
  59. my %count = ();
  60. my %comments = ();
  61. my $strcount = 0;
  62.  
  63. my $XMLCOMMENT = "";
  64.  
  65. ## Use this instead of \w for XML files to handle more possible characters.
  66. my $w = "[-A-Za-z0-9._:]";
  67.  
  68. ## Always print first
  69. $| = 1;
  70.  
  71. ## Handle options
  72. GetOptions (
  73.         "type=s"     => \$TYPE_ARG,
  74.             "local|l"    => \$LOCAL_ARG,
  75.             "help|h"     => \$HELP_ARG,
  76.             "version|v"  => \$VERSION_ARG,
  77.             "update"     => \$UPDATE_ARG,
  78.         "quiet|q"    => \$QUIET_ARG,
  79.         "srcdir=s"     => \$SRCDIR_ARG,
  80.         "nomsgctxt"  => \$NOMSGCTXT_ARG,            
  81.             ) or &error;
  82.  
  83. &split_on_argument;
  84.  
  85.  
  86. ## Check for options. 
  87. ## This section will check for the different options.
  88.  
  89. sub split_on_argument {
  90.  
  91.     if ($VERSION_ARG) {
  92.         &version;
  93.  
  94.     } elsif ($HELP_ARG) {
  95.     &help;
  96.         
  97.     } elsif ($LOCAL_ARG) {
  98.         &place_local;
  99.         &extract;
  100.  
  101.     } elsif ($UPDATE_ARG) {
  102.     &place_normal;
  103.     &extract;
  104.  
  105.     } elsif (@ARGV > 0) {
  106.     &place_normal;
  107.     &message;
  108.     &extract;
  109.  
  110.     } else {
  111.     &help;
  112.  
  113.     }  
  114. }    
  115.  
  116. sub place_normal {
  117.     $FILE     = $ARGV[0];
  118.     $OUTFILE     = "$FILE.h";
  119.  
  120.     my $dirname = dirname ($OUTFILE);
  121.     if (! -d "$dirname" && $dirname ne "") {
  122.         system ("mkdir -p $dirname");
  123.     }
  124. }   
  125.  
  126. sub place_local {
  127.     $FILE     = $ARGV[0];
  128.     $OUTFILE     = fileparse($FILE, ());
  129.     if (!-e "tmp/") { 
  130.         system("mkdir tmp/"); 
  131.     }
  132.     $OUTFILE     = "./tmp/$OUTFILE.h"
  133. }
  134.  
  135. sub determine_type {
  136.    if ($TYPE_ARG =~ /^gettext\/(.*)/) {
  137.     $gettext_type=$1
  138.    }
  139. }
  140.  
  141. ## Sub for printing release information
  142. sub version{
  143.     print <<_EOF_;
  144. ${PROGRAM} (${PACKAGE}) $VERSION
  145. Copyright (C) 2000, 2003 Free Software Foundation, Inc.
  146. Written by Kenneth Christiansen, 2000.
  147.  
  148. This is free software; see the source for copying conditions.  There is NO
  149. warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
  150. _EOF_
  151.     exit;
  152. }
  153.  
  154. ## Sub for printing usage information
  155. sub help {
  156.     print <<_EOF_;
  157. Usage: ${PROGRAM} [OPTION]... [FILENAME]
  158. Generates a header file from an XML source file.
  159.  
  160. It grabs all strings between <_translatable_node> and its end tag in
  161. XML files. Read manpage (man ${PROGRAM}) for more info.
  162.  
  163.       --type=TYPE   Specify the file type of FILENAME. Currently supports:
  164.                     "gettext/glade", "gettext/ini", "gettext/keys"
  165.                     "gettext/rfc822deb", "gettext/schemas",
  166.                     "gettext/scheme", "gettext/xml", "gettext/quoted",
  167.                     "gettext/quotedxml"
  168.   -l, --local       Writes output into current working directory
  169.                     (conflicts with --update)
  170.       --update      Writes output into the same directory the source file 
  171.                     reside (conflicts with --local)
  172.       --srcdir      Root of the source tree
  173.   -v, --version     Output version information and exit
  174.   -h, --help        Display this help and exit
  175.   -q, --quiet       Quiet mode
  176.  
  177. Report bugs to http://bugzilla.gnome.org/ (product name "$PACKAGE")
  178. or send email to <xml-i18n-tools\@gnome.org>.
  179. _EOF_
  180.     exit;
  181. }
  182.  
  183. ## Sub for printing error messages
  184. sub error{
  185.     print STDERR "Try `${PROGRAM} --help' for more information.\n";
  186.     exit;
  187. }
  188.  
  189. sub message {
  190.     print "Generating C format header file for translation.\n" unless $QUIET_ARG;
  191. }
  192.  
  193. sub extract {
  194.     &determine_type;
  195.  
  196.     &convert;
  197.  
  198.     open OUT, ">$OUTFILE";
  199.     binmode (OUT) if $^O eq 'MSWin32';
  200.     &msg_write;
  201.     close OUT;
  202.  
  203.     print "Wrote $OUTFILE\n" unless $QUIET_ARG;
  204. }
  205.  
  206. sub convert {
  207.  
  208.     ## Reading the file
  209.     {
  210.     local (*IN);
  211.     local $/; #slurp mode
  212.     open (IN, "<$SRCDIR_ARG/$FILE") || die "can't open $SRCDIR_ARG/$FILE: $!";
  213.     $input = <IN>;
  214.     }
  215.  
  216.     &type_ini if $gettext_type eq "ini";
  217.     &type_keys if $gettext_type eq "keys";
  218.     &type_xml if $gettext_type eq "xml";
  219.     &type_glade if $gettext_type eq "glade";
  220.     &type_scheme if $gettext_type eq "scheme";
  221.     &type_schemas  if $gettext_type eq "schemas";
  222.     &type_rfc822deb  if $gettext_type eq "rfc822deb";
  223.     &type_quoted if $gettext_type eq "quoted";
  224.     &type_quotedxml if $gettext_type eq "quotedxml";
  225. }
  226.  
  227. sub entity_decode_minimal
  228. {
  229.     local ($_) = @_;
  230.  
  231.     s/'/'/g; # '
  232.     s/"/"/g; # "
  233.     s/&/&/g;
  234.  
  235.     return $_;
  236. }
  237.  
  238. sub entity_decode
  239. {
  240.     local ($_) = @_;
  241.  
  242.     s/'/'/g; # '
  243.     s/"/"/g; # "
  244.     s/</</g;
  245.     s/>/>/g;
  246.     s/&/&/g;
  247.  
  248.     return $_;
  249. }
  250.  
  251. sub escape_char
  252. {
  253.     return '\"' if $_ eq '"';
  254.     return '\n' if $_ eq "\n";
  255.     return '\\\\' if $_ eq '\\';
  256.  
  257.     return $_;
  258. }
  259.  
  260. sub escape
  261. {
  262.     my ($string) = @_;
  263.     return join "", map &escape_char, split //, $string;
  264. }
  265.  
  266. sub type_ini {
  267.     ### For generic translatable desktop files ###
  268.     while ($input =~ /^(#(.+)\n)?^_.*=(.*)$/mg) {
  269.         if (defined($2))  {
  270.             $comments{$3} = $2;
  271.         }
  272.         $messages{$3} = [];
  273.     }
  274. }
  275.  
  276. sub type_keys {
  277.     ### For generic translatable mime/keys files ###
  278.     while ($input =~ /^\s*_\w+=(.*)$/mg) {
  279.         $messages{$1} = [];
  280.     }
  281. }
  282.  
  283. sub type_xml {
  284.     ### For generic translatable XML files ###
  285.     my $tree = readXml($input);
  286.     parseTree(0, $tree);
  287. }
  288.  
  289. sub print_var {
  290.     my $var = shift;
  291.     my $vartype = ref $var;
  292.     
  293.     if ($vartype =~ /ARRAY/) {
  294.         my @arr = @{$var};
  295.         print "[ ";
  296.         foreach my $el (@arr) {
  297.             print_var($el);
  298.             print ", ";
  299.         }
  300.         print "] ";
  301.     } elsif ($vartype =~ /HASH/) {
  302.         my %hash = %{$var};
  303.         print "{ ";
  304.         foreach my $key (keys %hash) {
  305.             print "$key => ";
  306.             print_var($hash{$key});
  307.             print ", ";
  308.         }
  309.         print "} ";
  310.     } else {
  311.         print $var;
  312.     }
  313. }
  314.  
  315. # Same syntax as getAttributeString in intltool-merge.in.in, similar logic (look for ## differences comment)
  316. sub getAttributeString
  317. {
  318.     my $sub = shift;
  319.     my $do_translate = shift || 1;
  320.     my $language = shift || "";
  321.     my $translate = shift;
  322.     my $result = "";
  323.     foreach my $e (reverse(sort(keys %{ $sub }))) {
  324.     my $key    = $e;
  325.     my $string = $sub->{$e};
  326.     my $quote = '"';
  327.     
  328.     $string =~ s/^[\s]+//;
  329.     $string =~ s/[\s]+$//;
  330.     
  331.     if ($string =~ /^'.*'$/)
  332.     {
  333.         $quote = "'";
  334.     }
  335.     $string =~ s/^['"]//g;
  336.     $string =~ s/['"]$//g;
  337.  
  338.         ## differences from intltool-merge.in.in
  339.     if ($key =~ /^_/) {
  340.             $comments{entity_decode($string)} = $XMLCOMMENT if $XMLCOMMENT;
  341.             $messages{entity_decode($string)} = [];
  342.             $$translate = 2;
  343.     }
  344.         ## differences end here from intltool-merge.in.in
  345.     $result .= " $key=$quote$string$quote";
  346.     }
  347.     return $result;
  348. }
  349.  
  350. # Verbatim copy from intltool-merge.in.in
  351. sub getXMLstring
  352. {
  353.     my $ref = shift;
  354.     my $spacepreserve = shift || 0;
  355.     my @list = @{ $ref };
  356.     my $result = "";
  357.  
  358.     my $count = scalar(@list);
  359.     my $attrs = $list[0];
  360.     my $index = 1;
  361.  
  362.     $spacepreserve = 1 if ((exists $attrs->{"xml:space"}) && ($attrs->{"xml:space"} =~ /^["']?preserve["']?$/));
  363.     $spacepreserve = 0 if ((exists $attrs->{"xml:space"}) && ($attrs->{"xml:space"} =~ /^["']?default["']?$/));
  364.  
  365.     while ($index < $count) {
  366.     my $type = $list[$index];
  367.     my $content = $list[$index+1];
  368.         if (! $type ) {
  369.         # We've got CDATA
  370.         if ($content) {
  371.         # lets strip the whitespace here, and *ONLY* here
  372.                 $content =~ s/\s+/ /gs if (!$spacepreserve);
  373.         $result .= $content;
  374.         }
  375.     } elsif ( "$type" ne "1" ) {
  376.         # We've got another element
  377.         $result .= "<$type";
  378.         $result .= getAttributeString(@{$content}[0], 0); # no nested translatable elements
  379.         if ($content) {
  380.         my $subresult = getXMLstring($content, $spacepreserve);
  381.         if ($subresult) {
  382.             $result .= ">".$subresult . "</$type>";
  383.         } else {
  384.             $result .= "/>";
  385.         }
  386.         } else {
  387.         $result .= "/>";
  388.         }
  389.     }
  390.     $index += 2;
  391.     }
  392.     return $result;
  393. }
  394.  
  395. # Verbatim copy from intltool-merge.in.in, except for MULTIPLE_OUTPUT handling removed
  396. # Translate list of nodes if necessary
  397. sub translate_subnodes
  398. {
  399.     my $fh = shift;
  400.     my $content = shift;
  401.     my $language = shift || "";
  402.     my $singlelang = shift || 0;
  403.     my $spacepreserve = shift || 0;
  404.  
  405.     my @nodes = @{ $content };
  406.  
  407.     my $count = scalar(@nodes);
  408.     my $index = 0;
  409.     while ($index < $count) {
  410.         my $type = $nodes[$index];
  411.         my $rest = $nodes[$index+1];
  412.         traverse($fh, $type, $rest, $language, $spacepreserve);
  413.         $index += 2;
  414.     }
  415. }
  416.  
  417. # Based on traverse() in intltool-merge.in.in
  418. sub traverse
  419. {
  420.     my $fh = shift; # unused, to allow us to sync code between -merge and -extract
  421.     my $nodename = shift;
  422.     my $content = shift;
  423.     my $language = shift || "";
  424.     my $spacepreserve = shift || 0;
  425.  
  426.     if ($nodename && "$nodename" eq "1") {
  427.         $XMLCOMMENT = $content;
  428.     } elsif ($nodename) {
  429.     # element
  430.     my @all = @{ $content };
  431.     my $attrs = shift @all;
  432.     my $translate = 0;
  433.     my $outattr = getAttributeString($attrs, 1, $language, \$translate);
  434.  
  435.     if ($nodename =~ /^_/) {
  436.         $translate = 1;
  437.         $nodename =~ s/^_//;
  438.     }
  439.     my $lookup = '';
  440.  
  441.         $spacepreserve = 0 if ((exists $attrs->{"xml:space"}) && ($attrs->{"xml:space"} =~ /^["']?default["']?$/));
  442.         $spacepreserve = 1 if ((exists $attrs->{"xml:space"}) && ($attrs->{"xml:space"} =~ /^["']?preserve["']?$/));
  443.  
  444.     if ($translate) {
  445.         $lookup = getXMLstring($content, $spacepreserve);
  446.             if (!$spacepreserve) {
  447.                 $lookup =~ s/^\s+//s;
  448.                 $lookup =~ s/\s+$//s;
  449.             }
  450.             if (exists $attrs->{"msgctxt"}) {
  451.                 my $context = entity_decode ($attrs->{"msgctxt"});
  452.                 $context =~ s/^["'](.*)["']/$1/;
  453.                 $lookup = "$context\004$lookup";
  454.             }
  455.  
  456.         if ($lookup && $translate != 2) {
  457.                 $comments{$lookup} = $XMLCOMMENT if $XMLCOMMENT;
  458.                 $messages{$lookup} = [];
  459.             } elsif ($translate == 2) {
  460.                 translate_subnodes($fh, \@all, $language, 1, $spacepreserve);
  461.         }
  462.     } else {
  463.             $XMLCOMMENT = "";
  464.         my $count = scalar(@all);
  465.         if ($count > 0) {
  466.                 my $index = 0;
  467.                 while ($index < $count) {
  468.                     my $type = $all[$index];
  469.                     my $rest = $all[$index+1];
  470.                     traverse($fh, $type, $rest, $language, $spacepreserve);
  471.                     $index += 2;
  472.                 }
  473.         }
  474.     }
  475.         $XMLCOMMENT = "";
  476.     }
  477. }
  478.  
  479.  
  480. # Verbatim copy from intltool-merge.in.in, $fh for compatibility
  481. sub parseTree
  482. {
  483.     my $fh        = shift;
  484.     my $ref       = shift;
  485.     my $language  = shift || "";
  486.  
  487.     my $name = shift @{ $ref };
  488.     my $cont = shift @{ $ref };
  489.  
  490.     while (!$name || "$name" eq "1") {
  491.         $name = shift @{ $ref };
  492.         $cont = shift @{ $ref };
  493.     }
  494.  
  495.     my $spacepreserve = 0;
  496.     my $attrs = @{$cont}[0];
  497.     $spacepreserve = 1 if ((exists $attrs->{"xml:space"}) && ($attrs->{"xml:space"} =~ /^["']?preserve["']?$/));
  498.  
  499.     traverse($fh, $name, $cont, $language, $spacepreserve);
  500. }
  501.  
  502. # Verbatim copy from intltool-merge.in.in
  503. sub intltool_tree_comment
  504. {
  505.     my $expat = shift;
  506.     my $data  = $expat->original_string();
  507.     my $clist = $expat->{Curlist};
  508.     my $pos   = $#$clist;
  509.  
  510.     $data =~ s/^<!--//s;
  511.     $data =~ s/-->$//s;
  512.     push @$clist, 1 => $data;
  513. }
  514.  
  515. # Verbatim copy from intltool-merge.in.in
  516. sub intltool_tree_cdatastart
  517. {
  518.     my $expat    = shift;
  519.     my $clist = $expat->{Curlist};
  520.     my $pos   = $#$clist;
  521.  
  522.     push @$clist, 0 => $expat->original_string();
  523. }
  524.  
  525. # Verbatim copy from intltool-merge.in.in
  526. sub intltool_tree_cdataend
  527. {
  528.     my $expat    = shift;
  529.     my $clist = $expat->{Curlist};
  530.     my $pos   = $#$clist;
  531.  
  532.     $clist->[$pos] .= $expat->original_string();
  533. }
  534.  
  535. # Verbatim copy from intltool-merge.in.in
  536. sub intltool_tree_char
  537. {
  538.     my $expat = shift;
  539.     my $text  = shift;
  540.     my $clist = $expat->{Curlist};
  541.     my $pos   = $#$clist;
  542.  
  543.     # Use original_string so that we retain escaped entities
  544.     # in CDATA sections.
  545.     #
  546.     if ($pos > 0 and $clist->[$pos - 1] eq '0') {
  547.         $clist->[$pos] .= $expat->original_string();
  548.     } else {
  549.         push @$clist, 0 => $expat->original_string();
  550.     }
  551. }
  552.  
  553. # Verbatim copy from intltool-merge.in.in
  554. sub intltool_tree_start
  555. {
  556.     my $expat    = shift;
  557.     my $tag      = shift;
  558.     my @origlist = ();
  559.  
  560.     # Use original_string so that we retain escaped entities
  561.     # in attribute values.  We must convert the string to an
  562.     # @origlist array to conform to the structure of the Tree
  563.     # Style.
  564.     #
  565.     my @original_array = split /\x/, $expat->original_string();
  566.     my $source         = $expat->original_string();
  567.  
  568.     # Remove leading tag.
  569.     #
  570.     $source =~ s|^\s*<\s*(\S+)||s;
  571.  
  572.     # Grab attribute key/value pairs and push onto @origlist array.
  573.     #
  574.     while ($source)
  575.     {
  576.        if ($source =~ /^\s*([\w:-]+)\s*[=]\s*["]/)
  577.        {
  578.            $source =~ s|^\s*([\w:-]+)\s*[=]\s*["]([^"]*)["]||s;
  579.            push @origlist, $1;
  580.            push @origlist, '"' . $2 . '"';
  581.        }
  582.        elsif ($source =~ /^\s*([\w:-]+)\s*[=]\s*[']/)
  583.        {
  584.            $source =~ s|^\s*([\w:-]+)\s*[=]\s*[']([^']*)[']||s;
  585.            push @origlist, $1;
  586.            push @origlist, "'" . $2 . "'";
  587.        }
  588.        else
  589.        {
  590.            last;
  591.        }
  592.     }
  593.  
  594.     my $ol = [ { @origlist } ];
  595.  
  596.     push @{ $expat->{Lists} }, $expat->{Curlist};
  597.     push @{ $expat->{Curlist} }, $tag => $ol;
  598.     $expat->{Curlist} = $ol;
  599. }
  600.  
  601. # Copied from intltool-merge.in.in and added comment handler.
  602. sub readXml
  603. {
  604.     my $xmldoc = shift || return;
  605.     my $ret = eval 'require XML::Parser';
  606.     if(!$ret) {
  607.         die "You must have XML::Parser installed to run $0\n\n";
  608.     }
  609.     my $xp = new XML::Parser(Style => 'Tree');
  610.     $xp->setHandlers(Char => \&intltool_tree_char);
  611.     $xp->setHandlers(Start => \&intltool_tree_start);
  612.     $xp->setHandlers(CdataStart => \&intltool_tree_cdatastart);
  613.     $xp->setHandlers(CdataEnd => \&intltool_tree_cdataend);
  614.  
  615.     ## differences from intltool-merge.in.in
  616.     $xp->setHandlers(Comment => \&intltool_tree_comment);
  617.     ## differences end here from intltool-merge.in.in
  618.  
  619.     my $tree = $xp->parse($xmldoc);
  620.     #print_var($tree);
  621.  
  622. # <foo><!-- comment --><head id="a">Hello <em>there</em></head><bar>Howdy<ref/></bar>do</foo>
  623. # would be:
  624. # [foo, [{}, 1, "comment", head, [{id => "a"}, 0, "Hello ",  em, [{}, 0, "there"]], bar, 
  625. # [{}, 0, "Howdy",  ref, [{}]], 0, "do" ] ]
  626.  
  627.     return $tree;
  628. }
  629.  
  630. sub type_schemas {
  631.     ### For schemas XML files ###
  632.          
  633.     # FIXME: We should handle escaped < (less than)
  634.     while ($input =~ /
  635.                       <locale\ name="C">\s*
  636.                           (<default>\s*(?:<!--([^>]*?)-->\s*)?(.*?)\s*<\/default>\s*)?
  637.                           (<short>\s*(?:<!--([^>]*?)-->\s*)?(.*?)\s*<\/short>\s*)?
  638.                           (<long>\s*(?:<!--([^>]*?)-->\s*)?(.*?)\s*<\/long>\s*)?
  639.                       <\/locale>
  640.                      /sgx) {
  641.         my @totranslate = ($3,$6,$9);
  642.         my @eachcomment = ($2,$5,$8);
  643.         foreach (@totranslate) {
  644.             my $currentcomment = shift @eachcomment;
  645.             next if !$_;
  646.             s/\s+/ /g;
  647.             $messages{entity_decode_minimal($_)} = [];
  648.             $comments{entity_decode_minimal($_)} = $currentcomment if (defined($currentcomment));
  649.         }
  650.     }
  651. }
  652.  
  653. sub type_rfc822deb {
  654.     ### For rfc822-style Debian configuration files ###
  655.  
  656.     my $lineno = 1;
  657.     my $type = '';
  658.     while ($input =~ /\G(.*?)(^|\n)(_+)([^:]+):[ \t]*(.*?)(?=\n\S|$)/sg)
  659.     {
  660.         my ($pre, $newline, $underscore, $tag, $text) = ($1, $2, $3, $4, $5);
  661.         while ($pre =~ m/\n/g)
  662.         {
  663.             $lineno ++;
  664.         }
  665.         $lineno += length($newline);
  666.         my @str_list = rfc822deb_split(length($underscore), $text);
  667.         for my $str (@str_list)
  668.         {
  669.             $strcount++;
  670.             $messages{$str} = [];
  671.             $loc{$str} = $lineno;
  672.             $count{$str} = $strcount;
  673.             my $usercomment = '';
  674.             while($pre =~ s/(^|\n)#([^\n]*)$//s)
  675.             {
  676.                 $usercomment = "\n" . $2 . $usercomment;
  677.             }
  678.             $comments{$str} = $tag . $usercomment;
  679.         }
  680.         $lineno += ($text =~ s/\n//g);
  681.     }
  682. }
  683.  
  684. sub rfc822deb_split {
  685.     # Debian defines a special way to deal with rfc822-style files:
  686.     # when a value contain newlines, it consists of
  687.     #   1.  a short form (first line)
  688.     #   2.  a long description, all lines begin with a space,
  689.     #       and paragraphs are separated by a single dot on a line
  690.     # This routine returns an array of all paragraphs, and reformat
  691.     # them.
  692.     # When first argument is 2, the string is a comma separated list of
  693.     # values.
  694.     my $type = shift;
  695.     my $text = shift;
  696.     $text =~ s/^[ \t]//mg;
  697.     return (split(/, */, $text, 0)) if $type ne 1;
  698.     return ($text) if $text !~ /\n/;
  699.  
  700.     $text =~ s/([^\n]*)\n//;
  701.     my @list = ($1);
  702.     my $str = '';
  703.     for my $line (split (/\n/, $text))
  704.     {
  705.         chomp $line;
  706.         if ($line =~ /^\.\s*$/)
  707.         {
  708.             #  New paragraph
  709.             $str =~ s/\s*$//;
  710.             push(@list, $str);
  711.             $str = '';
  712.         }
  713.         elsif ($line =~ /^\s/)
  714.         {
  715.             #  Line which must not be reformatted
  716.             $str .= "\n" if length ($str) && $str !~ /\n$/;
  717.             $line =~ s/\s+$//;
  718.             $str .= $line."\n";
  719.         }
  720.         else
  721.         {
  722.             #  Continuation line, remove newline
  723.             $str .= " " if length ($str) && $str !~ /\n$/;
  724.             $str .= $line;
  725.         }
  726.     }
  727.     $str =~ s/\s*$//;
  728.     push(@list, $str) if length ($str);
  729.     return @list;
  730. }
  731.  
  732. sub type_quoted {
  733.     while ($input =~ /\"(([^\"]|\\\")*[^\\\"])\"/g) {
  734.         my $message = $1;
  735.         my $before = $`;
  736.         $message =~ s/\\\"/\"/g;
  737.         $before =~ s/[^\n]//g;
  738.         $messages{$message} = [];
  739.         $loc{$message} = length ($before) + 2;
  740.     }
  741. }
  742.  
  743. sub type_quotedxml {
  744.     while ($input =~ /\"(([^\"]|\\\")*[^\\\"])\"/g) {
  745.         my $message = $1;
  746.         my $before = $`;
  747.         $message =~ s/\\\"/\"/g;
  748.         $message = entity_decode($message);
  749.         $before =~ s/[^\n]//g;
  750.         $messages{$message} = [];
  751.         $loc{$message} = length ($before) + 2;
  752.     }
  753. }
  754.  
  755. sub type_glade {
  756.     ### For translatable Glade XML files ###
  757.  
  758.     my $tags = "label|title|text|format|copyright|comments|preview_text|tooltip|message";
  759.  
  760.     while ($input =~ /<($tags)>([^<]+)<\/($tags)>/sg) {
  761.     # Glade sometimes uses tags that normally mark translatable things for
  762.         # little bits of non-translatable content. We work around this by not
  763.         # translating strings that only includes something like label4 or window1.
  764.     $messages{entity_decode($2)} = [] unless $2 =~ /^(window|label|dialog)[0-9]+$/;
  765.     }
  766.     
  767.     while ($input =~ /<items>(..[^<]*)<\/items>/sg) {
  768.     for my $item (split (/\n/, $1)) {
  769.         $messages{entity_decode($item)} = [];
  770.     }
  771.     }
  772.  
  773.     ## handle new glade files
  774.     while ($input =~ /<(property|atkproperty|col)\s+[^>]*translatable\s*=\s*"yes"(?:\s+[^>]*comments\s*=\s*"([^"]*)")?[^>]*>([^<]+)<\/\1>/sg) {
  775.     $messages{entity_decode($3)} = [] unless $3 =~ /^(window|label)[0-9]+$/;
  776.         if (defined($2) and !($3 =~ /^(window|label)[0-9]+$/)) {
  777.        $comments{entity_decode($3)} = entity_decode($2) ;
  778.         }
  779.     }
  780.     while ($input =~ /<atkaction\s+action_name="([^>]*)"\s+description="([^>]+)"\/>/sg) {
  781.         $messages{entity_decode_minimal($2)} = [];
  782.     }
  783. }
  784.  
  785. sub type_scheme {
  786.     my ($line, $i, $state, $str, $trcomment, $char);
  787.     for $line (split(/\n/, $input)) {
  788.         $i = 0;
  789.         $state = 0; # 0 - nothing, 1 - string, 2 - translatable string
  790.         while ($i < length($line)) {
  791.             if (substr($line,$i,1) eq "\"") {
  792.                 if ($state == 2) {
  793.                     $comments{$str} = $trcomment if ($trcomment);
  794.                     $messages{$str} = [];
  795.                     $str = '';
  796.                     $state = 0; $trcomment = "";
  797.                 } elsif ($state == 1) {
  798.                     $str = '';
  799.                     $state = 0; $trcomment = "";
  800.                 } else {
  801.                     $state = 1;
  802.                     $str = '';
  803.                     if ($i>0 && substr($line,$i-1,1) eq '_') {
  804.                         $state = 2;
  805.                     }
  806.                 }
  807.             } elsif (!$state) {
  808.                 if (substr($line,$i,1) eq ";") {
  809.                     $trcomment = substr($line,$i+1);
  810.                     $trcomment =~ s/^;*\s*//;
  811.                     $i = length($line);
  812.                 } elsif ($trcomment && substr($line,$i,1) !~ /\s|\(|\)|_/) {
  813.                     $trcomment = "";
  814.                 }
  815.             } else {
  816.                 if (substr($line,$i,1) eq "\\") {
  817.                     $char = substr($line,$i+1,1);
  818.                     if ($char ne "\"" && $char ne "\\") {
  819.                        $str = $str . "\\";
  820.                     }
  821.                     $i++;
  822.                 }
  823.                 $str = $str . substr($line,$i,1);
  824.             }
  825.             $i++;
  826.         }
  827.     }
  828. }
  829.  
  830. sub msg_write {
  831.     my @msgids;
  832.     if (%count)
  833.     {
  834.         @msgids = sort { $count{$a} <=> $count{$b} } keys %count;
  835.     }
  836.     else
  837.     {
  838.         @msgids = sort keys %messages;
  839.     }
  840.     for my $message (@msgids)
  841.     {
  842.     my $offsetlines = 1;
  843.     my $context = undef;
  844.     $offsetlines++ if $message =~ /%/;
  845.     if (defined ($comments{$message}))
  846.     {
  847.         while ($comments{$message} =~ m/\n/g)
  848.         {
  849.             $offsetlines++;
  850.         }
  851.     }
  852.     print OUT "# ".($loc{$message} - $offsetlines).  " \"$FILE\"\n"
  853.             if defined $loc{$message};
  854.        print OUT "/* ".$comments{$message}." */\n"
  855.                 if defined $comments{$message};
  856.        print OUT "/* xgettext:no-c-format */\n" if $message =~ /%/;
  857.         
  858.         if ($message =~ /(.*)\004(.*)/) {
  859.             $context = $1;
  860.             $message = $2;
  861.         }
  862.         my @lines = split (/\n/, $message, -1);
  863.         for (my $n = 0; $n < @lines; $n++)
  864.     {
  865.             if ($n == 0)
  866.             {
  867.                 if (defined $context)
  868.                 {
  869.                      if ($NOMSGCTXT_ARG)
  870.                      {
  871.                           print OUT "char *s = N_(\"", $context, "|"; 
  872.                      }
  873.                      else
  874.                      {
  875.                    print OUT "char *s = C_(\"", $context, "\", \""; 
  876.                      }
  877.                 }
  878.                 else
  879.                 {
  880.               print OUT "char *s = N_(\""; 
  881.                 }
  882.             }
  883.             else
  884.             {  
  885.                 print OUT "             \""; 
  886.             }
  887.  
  888.             print OUT escape($lines[$n]);
  889.  
  890.             if ($n < @lines - 1)
  891.             {
  892.                 print OUT "\\n\"\n"; 
  893.             }
  894.             else
  895.             {
  896.                 print OUT "\");\n";  
  897.         }
  898.         }
  899.     }
  900. }
  901.  
  902.